home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / vaxlocgen.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  15.3 KB  |  331 lines
  1. (herald (back_end vaxlocgen)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Copyright (c) 1985 David Kranz
  28.                              
  29.  
  30. (define (generate-set-location node)    ;; cont type-primop value . args
  31.   ((xselect (length (call-args node))
  32.      ((4) generate-set-fixed-accessor)
  33.      ((5) generate-set-vector-elt))
  34.    node))
  35.  
  36.  
  37. (define (generate-set-fixed-accessor node)
  38.   (destructure (((#f type value loc) (call-args node)))
  39.     (let* ((prim (leaf-value type))
  40.            (do-it 
  41.             (lambda (access)
  42.               (cond ((and (eq? prim primop/cell-value)
  43.                           (eq? (variable-definition (leaf-value loc)) 'one))
  44.                      (let ((lc (access-value node (leaf-value loc))))
  45.                        (generate-move access lc)
  46.                        (cond ((and (register? lc) (temp-loc (leaf-value loc)))
  47.                               => (lambda (lc)
  48.                                    (set (temp-node lc) nil)
  49.                                    (set (temp-loc (leaf-value loc)) nil))))))
  50.                     (else
  51.                      (let ((reg (->register 'pointer node (leaf-value loc) '*)))
  52.                        (generate-move access
  53.                              (reg-offset reg (primop.location-specs prim)))))))))
  54.       (cond ((lambda-node? value)
  55.              (let ((access (access/make-closure node value)))
  56.                (if access (protect-access access) (lock AN))
  57.                (do-it (if access access AN))
  58.                (if access (release-access access) (unlock AN))))
  59.             (else
  60.              (let ((access (access-with-rep node (leaf-value value) 'rep/pointer)))
  61.                (protect-access access)                         
  62.                (do-it access)
  63.                (release-access access)))))))
  64.                     
  65. (define (generate-set-vector-type-length node)
  66.   (destructure (((#f vec val) (call-args node)))
  67.     (let ((reg (->register 'pointer node (leaf-value vec) '*))
  68.           (val (leaf-value val)))
  69.       (lock reg)
  70.       (let ((scratch (get-register 'scratch node '*)))
  71.         (cond ((variable? val)
  72.                (emit vax/ashl 
  73.                      (machine-num (if (eq? (variable-rep val) 'rep/pointer) 6 8))
  74.                       (access-value node val) scratch))
  75.               (else 
  76.                (emit vax/movl (machine-num (fixnum-ashl val 8)) scratch)))
  77.         (emit vax/movb (reg-offset reg -2) scratch)
  78.         (emit vax/movl scratch (reg-offset reg -2))
  79.         (unlock reg)))))
  80.                
  81.                                                      
  82.                     
  83. (define (generate-set-vector-elt node)
  84.   (destructure (((#f type value loc idex) (call-args node)))
  85.     (let ((idex (leaf-value idex))
  86.           (rep (primop.rep-wants (leaf-value type)))
  87.       (reg (->register 'pointer node (leaf-value loc) '*)))
  88.       (lock reg)
  89.       (cond ((eq? rep 'rep/pointer)
  90.              (let* ((access (if (lambda-node? value)
  91.                                 (access/make-closure node value)
  92.                                 (access-value node (leaf-value value))))
  93.                     (value-acc (if access access AN)))
  94.                (if access (protect-access access) (lock AN))
  95.                (let* ((i-acc (access-with-rep node idex 'rep/integer))
  96.                       (i-reg (cond ((register? i-acc) i-acc)
  97.                                    (else
  98.                                     (let ((i (get-register 'scratch node '*)))
  99.                                       (emit vax/movl i-acc i)
  100.                                       i)))))
  101.                  (generate-move value-acc (index (d@r reg tag/extend) i-reg))
  102.          (unlock reg)
  103.                  (if access (release-access access) (unlock AN)))))
  104.             (else                                                               
  105.              (let* ((i-acc (access-with-rep node idex 'rep/integer))
  106.                     (i-reg (cond ((and (register? i-acc)
  107.                                        (eq? (rep-size rep) size/byte))
  108.                                   i-acc)
  109.                                  (else
  110.                                   (let ((i (get-register 'scratch node '*)))
  111.                                     (xselect (rep-size rep)
  112.                                       ((size/byte)
  113.                                        (emit vax/movl i-acc i))
  114.                                       ((size/word)
  115.                                        (emit vax/ashl (machine-num -1) i-acc i))
  116.                                       ((size/long)
  117.                                        (emit vax/ashl (machine-num -2) i-acc i)))
  118.                                     i))))
  119.                     (value (leaf-value value)))
  120.                  (lock i-reg)
  121.                  (cond ((variable? value)                       
  122.                         (let ((acc (access-value node value)))
  123.                           (protect-access acc)
  124.                           (really-rep-convert node acc (variable-rep value)
  125.                                    (index (d@r reg tag/extend) i-reg)
  126.                                    rep)
  127.                           (release-access acc)))
  128.                        (else
  129.                         (really-rep-convert node (value-with-rep value rep)
  130.                                             rep
  131.                                             (index (d@r reg tag/extend) i-reg)
  132.                                             rep)))
  133.                  (unlock i-reg)
  134.                  (unlock reg)))))))
  135.  
  136.  
  137.                    
  138.                         
  139. (define (generate-contents-location node)
  140.   ((xselect (length (call-args node))
  141.      ((3) generate-fixed-accessor)
  142.      ((4) generate-vector-elt))
  143.    node))
  144.  
  145. (define (generate-fixed-accessor node)
  146.   (destructure (((cont type loc) (call-args node)))
  147.    (if (or (leaf-node? cont) (used? (car (lambda-variables cont))))   
  148.        (receive (t-spec t-rep) (continuation-wants cont)
  149.          (let* ((type (leaf-value type))
  150.                 (base (leaf-value loc))
  151.                 (target (get-target-register node t-spec)))
  152.            (cond ((and (eq? type primop/cell-value)
  153.                        (eq? (variable-definition base) 'one))
  154.                   (really-rep-convert node (access-value node base)
  155.                                       'rep/pointer target t-rep))
  156.                  (else
  157.                   (let ((reg (->register 'pointer node base '*)))
  158.                     (really-rep-convert node 
  159.                                (reg-offset reg (primop.location-specs type))
  160.                                'rep/pointer target t-rep))))
  161.            (cond ((reg-node target) 
  162.                   => (lambda (node) (set (register-loc node) nil))))
  163.            (mark-continuation node target))))))
  164.  
  165.  
  166. (define (generate-vector-type-length node)
  167.   (destructure (((cont vec) (call-args node)))
  168.     (receive (t-spec t-rep) (continuation-wants cont)
  169.       (let* ((base (leaf-value vec))
  170.              (target (get-target-register node t-spec))
  171.              (reg (->register 'pointer node base '*))
  172.              (temp (if (eq? (reg-type target) 'scratch) 
  173.                        target 
  174.                        (get-register 'scratch node '*))))
  175.         (emit vax/ashl (machine-num -8) (reg-offset reg -2) temp)
  176.         (if (eq? t-rep 'rep/pointer)
  177.             (emit vax/ashl (machine-num 2) temp temp))
  178.         (generate-move temp target)
  179.         (cond ((reg-node target) 
  180.                => (lambda (node) (set (register-loc node) nil))))
  181.         (mark-continuation node target)))))
  182.  
  183.  
  184.                                                
  185. (define (generate-vector-elt node)
  186.   (destructure (((cont type loc idex) (call-args node)))
  187.     (receive (t-spec t-rep) (continuation-wants cont)
  188.       (let* ((base (leaf-value loc))
  189.              (type (leaf-value type))
  190.              (idex (leaf-value idex))
  191.              (t-reg (get-target-register node t-spec))
  192.              (rep (primop.rep-wants type))
  193.              (reg (->register 'pointer node base '*)))
  194.         (lock reg) 
  195.         (cond ((fixnum? idex)
  196.                (really-rep-convert node 
  197.                         (d@r reg (fx+ (if (eq? rep 'rep/pointer) 
  198.                                           (fx* idex 4)
  199.                                           idex)
  200.                                       tag/extend))
  201.                         rep t-reg t-rep))
  202.               (else 
  203.                (let* ((i-acc (access-with-rep node idex 'rep/integer))
  204.                       (i-reg (cond ((and (register? i-acc)
  205.                                          (or (eq? (rep-size rep) size/byte)
  206.                                              (eq? rep 'rep/pointer)))
  207.                                     i-acc)
  208.                                    ((eq? rep 'rep/pointer)           
  209.                                     (let ((i (get-register 'scratch node '*)))
  210.                                        (emit vax/movl i-acc i)
  211.                                        i))
  212.                                    (else
  213.                                     (let ((i (get-register 'scratch node '*)))
  214.                                       (select (rep-size rep)
  215.                                         ((size/byte)
  216.                                          (emit vax/movl i-acc i))
  217.                                         ((size/word)
  218.                                          (emit vax/ashl (machine-num -1) i-acc i))
  219.                                         ((size/long)
  220.                                          (emit vax/ashl (machine-num -2) i-acc i)))
  221.                                     i)))))
  222.                  (really-rep-convert node (index (d@r reg tag/extend) i-reg)
  223.                                      rep t-reg t-rep))))
  224.           (unlock reg)
  225.           (cond ((reg-node t-reg) 
  226.                  => (lambda (node) (set (register-loc node) nil))))
  227.           (mark-continuation node t-reg)))))
  228.  
  229.  
  230. (define (generate-make-pointer node)
  231.   (destructure (((cont loc idex) (call-args node)))
  232.     (receive (t-spec t-rep) (continuation-wants cont)
  233.       (let ((t-reg (get-target-register node t-spec))
  234.             (reg (->register 'pointer node (leaf-value loc) '*)))
  235.         (lock reg)
  236.         (let* ((i-acc (access-with-rep node (leaf-value idex) 'rep/integer))
  237.                (i-reg (cond ((register? i-acc) i-acc)
  238.                             (else
  239.                              (let ((i (get-register 'scratch node '*)))
  240.                                (emit vax/movl i-acc i)
  241.                                i)))))
  242.           (emit vax/moval (index (d@r reg 4) i-reg) t-reg))
  243.         (unlock reg)
  244.         (cond ((reg-node t-reg) 
  245.                => (lambda (node) (set (register-loc node) nil))))
  246.         (mark-continuation node t-reg)))))
  247.  
  248.  
  249. (define (generate-location-access node)
  250.   ((xselect (length (call-args node))
  251.      ((3) defer-fixed-accessor)
  252.      ((4) defer-vector-elt))
  253.    node))
  254.  
  255. (define (defer-fixed-accessor node)
  256.   (destructure (((cont type loc) (call-args node)))
  257.     (let* ((type (leaf-value type))
  258.            (base (leaf-value loc))
  259.            (reg (->register 'pointer node base '*)))
  260.       (lock reg)
  261.       (set (register-loc (car (lambda-variables cont)))
  262.            (cons reg (primop.location-specs type)))
  263.       (allocate-call (lambda-body cont)))))
  264.  
  265.  
  266.  
  267. (define (defer-vector-elt node)
  268.   (destructure (((cont type loc index) (call-args node)))
  269.     (let* ((base (leaf-value loc))
  270.            (type (leaf-value type))
  271.            (index (leaf-value index))   
  272.            (rep (primop.rep-wants type))
  273.            (reg (->register 'pointer node base '*)))
  274.       (lock reg)                                                            
  275.       (cond ((fixnum? index)
  276.              (set (register-loc (car (lambda-variables cont)))
  277.                   (cons reg (fx+ (if (eq? rep 'rep/pointer)   
  278.                                      (fx* index 4)
  279.                                      index)
  280.                                  tag/extend))))
  281.             (else
  282.              (let* ((i-acc (access-with-rep node index 'rep/integer))
  283.                     (i-reg (cond ((and (register? i-acc)
  284.                                        (or (eq? (rep-size rep) size/byte)
  285.                                            (eq? rep 'rep/pointer)))
  286.                                   i-acc)
  287.                                  (else
  288.                                   (let ((i (get-register 'scratch node '*)))
  289.                                     (if (eq? rep 'rep/pointer)
  290.                                         (emit vax/movl i-acc i)
  291.                                         (select (rep-size rep)         
  292.                                           ((size/byte)
  293.                                            (emit vax/movl i-acc i))
  294.                                           ((size/word)
  295.                                            (emit vax/ashl (machine-num -1) i-acc i))
  296.                                           ((size/long)
  297.                                            (emit vax/ashl (machine-num -2) i-acc i))))
  298.                                       i)))))
  299.                (unlock reg)
  300.                (kill-if-dying index node)
  301.                (lock reg)
  302.                (lock i-reg)
  303.                (set (register-loc (car (lambda-variables cont)))
  304.                     (cons (cons reg i-reg) 2)))))
  305.       (allocate-call (lambda-body cont)))))
  306.           
  307.           
  308.                     
  309.                     
  310. (define (generate-%chdr node)
  311.   (destructure (((#f vec val) (call-args node)))
  312.     (let ((reg (->register 'pointer node (leaf-value vec) '*))
  313.           (val (leaf-value val)))
  314.       (lock reg)                                              
  315.       (cond ((fixnum? val)
  316.              (if (fx= val 1)
  317.                  (emit vax/incl (reg-offset reg offset/string-base))
  318.                  (emit vax/addl2 (machine-num val) 
  319.                        (reg-offset reg offset/string-base)))
  320.              (emit vax/subl2 (machine-num (fixnum-ashl val 8))
  321.                    (reg-offset reg -2)))
  322.             (else
  323.              (let* ((n (access-with-rep node val 'rep/integer)))
  324.                (emit vax/addl2 n (reg-offset reg offset/string-base))
  325.                (let ((s (get-register 'scratch node '*)))
  326.                  (emit vax/ashl (machine-num 8) n s)
  327.                  (emit vax/subl2 s (reg-offset reg -2))))))
  328.       (unlock reg))))
  329.                
  330.  
  331.